home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue59 / IBSec / MainForm.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-03-29  |  12.2 KB  |  387 lines
  1. unit MainForm;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, ExtCtrls, ScktComp, Menus, WinCrypt;
  8.  
  9. Const
  10.   wm_ConnectSocket    = wm_User+1000;
  11.   wm_SendQueue        = wm_User+1001;
  12.   wm_DisconnectClient = wm_User+1002;
  13.  
  14. type
  15.   TIBSecMainForm = class(TForm)
  16.     Operation: TRadioGroup;
  17.     Log: TMemo;
  18.     Label1: TLabel;
  19.     SecurePort: TEdit;
  20.     Label2: TLabel;
  21.     Password: TEdit;
  22.     StartStop: TButton;
  23.     IBPort: TLabel;
  24.     ServerSocket: TServerSocket;
  25.     Label3: TLabel;
  26.     ServerHost: TEdit;
  27.     ClearLogMenu: TPopupMenu;
  28.     ClearLog1: TMenuItem;
  29.     LogEnabled1: TMenuItem;
  30.     CAPIVersion: TLabel;
  31.     CryptData: TCheckBox;
  32.     procedure StartStopClick(Sender: TObject);
  33.     procedure FormShow(Sender: TObject);
  34.     procedure ServerSocketClientRead(Sender: TObject;
  35.       Socket: TCustomWinSocket);
  36.     procedure ServerSocketClientConnect(Sender: TObject;
  37.       Socket: TCustomWinSocket);
  38.     procedure ServerSocketClientDisconnect(Sender: TObject;
  39.       Socket: TCustomWinSocket);
  40.     procedure ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
  41.     procedure OperationClick(Sender: TObject);
  42.     procedure ClientSocketDisconnect(Sender: TObject;
  43.       Socket: TCustomWinSocket);
  44.     procedure ServerSocketClientError(Sender: TObject;
  45.       Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  46.       var ErrorCode: Integer);
  47.     procedure ClientSocketError(Sender: TObject; Socket: TCustomWinSocket;
  48.       ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  49.     procedure ClientSocketConnect(Sender: TObject;
  50.       Socket: TCustomWinSocket);
  51.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  52.     procedure ClearLog1Click(Sender: TObject);
  53.     procedure LogEnabled1Click(Sender: TObject);
  54.   private
  55.     { Private declarations }
  56.     CAPIProvider : TCryptProv;
  57.     CAPIKey      : TCryptKey;
  58.     CAPIHash     : TCryptHash;
  59.     SendQueue    : TThreadList;
  60.     Procedure AcquireCAPIContext;
  61.     Procedure CreateCAPIKey;
  62.     Function GetCAPIVersion : String;
  63.     Procedure Encrypt(Buffer : PChar; BufLen : Integer);
  64.     Procedure Decrypt(Buffer : PChar; BufLen : Integer);
  65.     Procedure LogMessage(Msg : String);
  66.     Procedure WMConnectSocket(Var Msg : TMessage); Message wm_ConnectSocket;
  67.     Procedure WMSendQueue(Var Msg : TMessage); Message wm_SendQueue;
  68.     Procedure WMDisconnectClient(Var Msg : TMessage); Message wm_DisconnectClient;
  69.   public
  70.     { Public declarations }
  71.   end;
  72.  
  73. var
  74.   IBSecMainForm: TIBSecMainForm;
  75.  
  76. implementation
  77.  
  78. {$R *.DFM}
  79.  
  80. Uses WinSock;
  81.  
  82. Const
  83.   Client = 0;
  84.   Server = 1;
  85.  
  86. Type
  87.   PDataQueueRec = ^TDataQueueRec;
  88.   TDataQueueRec = Record
  89.     ServerSocket : TCustomWinSocket;
  90.     DataBuffer   : PChar;
  91.     BufferLen    : Integer;
  92.   End;
  93.  
  94. Procedure TIBSecMainForm.AcquireCAPIContext;
  95. Begin
  96.   If (Not CryptAcquireContext(@CAPIProvider,nil,MSDefProv,ProvRSAFull,0)) Then Begin
  97.     { Couldn't acquire context -- try to create a new keyset (init user). }
  98.     If (Not CryptAcquireContext(@CAPIProvider,nil,MSDefProv,ProvRSAFull,CryptNewKeySet)) Then Begin
  99.       Raise Exception.Create('Cannot acquire context to default provider: '+
  100.                              SysErrorMessage(GetLastError));
  101.     End;
  102.   End;
  103. End;
  104.  
  105. Function TIBSecMainForm.GetCAPIVersion : String;
  106. Var I,J : Integer;
  107. Begin
  108.   J := SizeOf(Integer);
  109.   If (Not CryptGetProvParam(CAPIProvider,PPVersion,@I,J,0)) Then Result := ''
  110.   Else Result := 'CAPI version '+IntToStr((I shr 8) And $FF)+'.'+IntToStr(I And $FF);
  111. End;
  112.  
  113. Procedure TIBSecMainForm.CreateCAPIKey;
  114. Begin
  115.   CryptCreateHash(CAPIProvider,CAlgMD5,0,0,@CAPIHash);
  116.   If (Not CryptHashData(CAPIHash,PChar(Password.Text),Length(Password.Text),0)) Then
  117.     Raise Exception.Create('Cannot hash data: '+SysErrorMessage(GetLastError));
  118.   CryptDeriveKey(CAPIProvider,CAlgRC4,CAPIHash,0,@CAPIKey);
  119.   If (CAPIKey = 0) Then Raise Exception.Create('Cannot create cryptographic key: '+
  120.     SysErrorMessage(GetLastError));
  121. End;
  122.  
  123. Procedure TIBSecMainForm.Encrypt(Buffer : PChar; BufLen : Integer);
  124. Begin
  125.   If (Not CryptEncrypt(CAPIKey,0,False,0,Buffer,BufLen,BufLen)) Then
  126.     Raise Exception.Create('Cannot encrypt data: '+SysErrorMessage(GetLastError));
  127. End;
  128.  
  129. Procedure TIBSecMainForm.Decrypt(Buffer : PChar; BufLen : Integer);
  130. Begin
  131.   If (Not CryptDecrypt(CAPIKey,0,False,0,Buffer,BufLen)) Then
  132.     Raise Exception.Create('Cannot decrypt data: '+SysErrorMessage(GetLastError));
  133. End;
  134.  
  135. Procedure TIBSecMainForm.LogMessage(Msg : String);
  136. Begin
  137.   If LogEnabled1.Checked Then Begin
  138.     Log.Lines.Insert(0,DateTimeToStr(Now)+' ['+IntToStr(GetCurrentThreadID)+']: '+Msg+'.');
  139.     Log.Update;
  140.   End;
  141. End;
  142.  
  143. procedure TIBSecMainForm.FormShow(Sender: TObject);
  144. begin
  145.   SendQueue := TThreadList.Create;
  146.   IBPort.Caption := 'InterBase port: '+IntToStr(ServerSocket.Socket.LookupService('gds_db'));
  147.   AcquireCAPIContext;
  148.   CreateCAPIKey;
  149.   CAPIVersion.Caption := GetCAPIVersion;
  150. end;
  151.  
  152. procedure TIBSecMainForm.OperationClick(Sender: TObject);
  153. begin
  154.   If (Operation.ItemIndex = Client) Then Label3.Caption := 'IBSec server:'
  155.   Else Label3.Caption := 'IB server:';
  156. end;
  157.  
  158. procedure TIBSecMainForm.StartStopClick(Sender: TObject);
  159. Var Service : String;
  160. begin
  161.   If (Operation.ItemIndex = Client) Then Begin
  162.     { an InterBase client application will contact IBSec }
  163.     ServerSocket.Port := 0;
  164.     ServerSocket.Service := 'gds_db';
  165.     ServerSocket.Active := True;
  166.     Service := 'client';
  167.     Application.Title := 'IBSec Client';
  168.     Caption := Application.Title;
  169.   End
  170.   Else Begin
  171.     { a client instance of IBSec will contact this application for secure communications }
  172.     ServerSocket.Port := StrToInt(SecurePort.Text);
  173.     ServerSocket.Service := '';
  174.     ServerSocket.Active := True;
  175.     Service := 'server';
  176.     Application.Title := 'IBSec Server';
  177.     Caption := Application.Title;
  178.   End;
  179.   { change the GUI to indicate operation }
  180.   Operation.Enabled := False;
  181.   ServerHost.Enabled := False;
  182.   SecurePort.Enabled := False;
  183.   Password.Enabled := False;
  184.   StartStop.Enabled := False;
  185.   CryptData.Enabled := False;
  186.   LogMessage('Starting '+Service+' services');
  187. end;
  188.  
  189. procedure TIBSecMainForm.ServerSocketClientConnect(Sender: TObject;
  190.   Socket: TCustomWinSocket);
  191. Var CS : TClientSocket;
  192. begin
  193.   LogMessage('Client '+Socket.RemoteAddress+' connect');
  194.   Assert(Socket.Data = nil);
  195.   CS := TClientSocket.Create(Self);
  196.   CS.Socket.Data := Socket;
  197.   Socket.Data := CS;
  198.   PostMessage(Handle,wm_ConnectSocket,Integer(CS),Integer(Socket));
  199. end;
  200.  
  201. procedure TIBSecMainForm.ServerSocketClientDisconnect(Sender: TObject;
  202.   Socket: TCustomWinSocket);
  203. begin
  204.   LogMessage('Client '+Socket.RemoteAddress+' disconnect');
  205.   With TClientSocket(Socket.Data) do Begin
  206.     Active := False;
  207.     Free;
  208.   End;
  209.   { make sure no dangling pointers exist }
  210.   Socket.Data := nil;
  211. end;
  212.  
  213. procedure TIBSecMainForm.ServerSocketClientRead(Sender: TObject;
  214.   Socket: TCustomWinSocket);
  215. Var
  216.   Buffer  : PChar;
  217.   BufLen  : Integer;
  218.   DataRec : PDataQueueRec;
  219.  
  220. begin
  221.   {
  222.   Client: the InterBase application has written data to this connection
  223.   Server: the IBSec client has written data to this connection
  224.   }
  225.   BufLen := 16*1024; { 16k }
  226.   Buffer := StrAlloc(BufLen);
  227.   BufLen := Socket.ReceiveBuf(Buffer^,BufLen);
  228.   If CryptData.Checked Then Begin
  229.     If (Operation.ItemIndex = Server) Then Decrypt(Buffer,BufLen)
  230.     Else Encrypt(Buffer,BufLen);
  231.   End;
  232.   LogMessage('ServerSocket.ClientRead '+IntToStr(BufLen)+' bytes');
  233.   If ((Socket.Data = nil) Or (Not TClientSocket(Socket.Data).Socket.Connected)) Then Begin
  234.     { save the buffer in a queue }
  235.     New(DataRec);
  236.     With DataRec^ do Begin
  237.       ServerSocket := Socket;
  238.       DataBuffer := Buffer;
  239.       BufferLen := BufLen;
  240.     End;
  241.     SendQueue.Add(DataRec);
  242.   End
  243.   Else Begin
  244.     { "slave" socket is ready, send data through it }
  245.     TClientSocket(Socket.Data).Socket.SendBuf(Buffer^,BufLen);
  246.   End;
  247. end;
  248.  
  249. procedure TIBSecMainForm.ClientSocketRead(Sender: TObject;
  250.   Socket: TCustomWinSocket);
  251. Var
  252.   Buffer : Array[0..16384] of Char;
  253.   BufLen : Integer;
  254.   Sent   : Integer;
  255.  
  256. begin
  257.   {
  258.   Client: the secure IBSec server has written something to the connection
  259.   Server: the InterBase server has written something to the connection
  260.   }
  261.   BufLen := Socket.ReceiveBuf(Buffer,SizeOf(Buffer));
  262.   LogMessage('ClientSocket.Read '+IntToStr(BufLen)+' bytes');
  263.   If CryptData.Checked Then Begin
  264.     If (Operation.ItemIndex = Client) Then Decrypt(Buffer,BufLen)
  265.     Else Encrypt(Buffer,BufLen);
  266.   End;
  267.   { send data to the other end of the socket }
  268.   Sent := TCustomWinSocket(Socket.Data).SendBuf(Buffer,BufLen);
  269.   If (Sent <> BufLen) Then LogMessage('Warning: could not send all bytes in ClientSocketRead');
  270. end;
  271.  
  272. procedure TIBSecMainForm.ClientSocketConnect(Sender: TObject;
  273.   Socket: TCustomWinSocket);
  274. begin
  275.   LogMessage('ClientSocket.Connect');
  276.   { make sure the send queue gets sent out }
  277.   PostMessage(Handle,wm_SendQueue,0,0);
  278. end;
  279.  
  280. procedure TIBSecMainForm.ClientSocketDisconnect(Sender: TObject;
  281.   Socket: TCustomWinSocket);
  282. begin
  283.   { disconnect the "master" connection also }
  284.   LogMessage('ClientSocket.Disconnect');
  285.   PostMessage(Handle,wm_DisconnectClient,0,Integer(Socket.Data));
  286. end;
  287.  
  288. procedure TIBSecMainForm.ServerSocketClientError(Sender: TObject;
  289.   Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  290.   var ErrorCode: Integer);
  291. begin
  292.   LogMessage('ServerSocket.ClientError '+IntToStr(ErrorCode));
  293.   If (ErrorCode = wsaeConnAborted) Then Begin
  294.     LogMessage('Connection aborted, closing client');
  295.     TClientSocket(Socket.Data).Close;
  296.     ErrorCode := 0; { don't raise a exception }
  297.   End;
  298. end;
  299.  
  300. procedure TIBSecMainForm.ClientSocketError(Sender: TObject;
  301.   Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  302.   var ErrorCode: Integer);
  303. begin
  304.   LogMessage('ClientSocket.ClientError '+IntToStr(ErrorCode));
  305. end;
  306.  
  307. Procedure TIBSecMainForm.WMConnectSocket(Var Msg : TMessage);
  308. Begin
  309.   LogMessage('Connecting client socket');
  310.   With TClientSocket(Msg.WParam) do Begin
  311.     If (Operation.ItemIndex = Client) Then Port := StrToInt(SecurePort.Text)
  312.     Else Service := 'gds_db';
  313.     Host := ServerHost.Text;
  314.     OnConnect := ClientSocketConnect;
  315.     OnRead := ClientSocketRead;
  316.     OnDisconnect := ClientSocketDisconnect;
  317.     OnError := ClientSocketError;
  318.     Socket.Data := Pointer(Msg.LParam);
  319.     Active := True; { open the socket }
  320.   End;
  321. End;
  322.  
  323. Procedure TIBSecMainForm.WMSendQueue(Var Msg : TMessage);
  324. Var
  325.   I,Bytes : Integer;
  326.   List    : TList;
  327.   Retry   : Boolean;
  328.   Client  : TClientSocket;
  329.   DataRec : PDataQueueRec;
  330.  
  331. Begin
  332.   Retry := False;
  333.   With SendQueue do Begin
  334.     List := LockList;
  335.     Try
  336.       LogMessage('Sending queued buffers: '+IntToStr(List.Count));
  337.       For I := 0 to List.Count-1 do Begin
  338.         DataRec := List[I];
  339.         With DataRec^ do Begin
  340.           Client := ServerSocket.Data;
  341.           If ((Client = nil) Or (Not Client.Socket.Connected)) Then Retry := True
  342.           Else Begin
  343.             Bytes := Client.Socket.SendBuf(DataBuffer^,BufferLen);
  344.             LogMessage(IntToStr(Bytes)+' bytes sent');
  345.             If (Bytes <> BufferLen) Then LogMessage('Warning: could not send all bytes in WMSendQueue');
  346.             List[I] := nil;
  347.             StrDispose(DataBuffer);
  348.             Dispose(DataRec);
  349.           End;
  350.         End;
  351.       End;
  352.       List.Pack; { pack the queue }
  353.       LogMessage('Queued buffers sent, '+IntToStr(List.Count)+' buffers still exist');
  354.     Finally
  355.       UnlockList;
  356.     End;
  357.   End;
  358.   If Retry Then Begin
  359.     LogMessage('Queue still holds buffers, resending them later');
  360.     PostMessage(Handle,wm_SendQueue,0,0); { retry the queue sending again later }
  361.   End;
  362. End;
  363.  
  364. Procedure TIBSecMainForm.WMDisconnectClient(Var Msg : TMessage);
  365. Begin
  366.   LogMessage('Handling ClientSocket.Disconnect');
  367.   TClientSocket(Pointer(Msg.LParam)).Close;
  368. End;
  369.  
  370. procedure TIBSecMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
  371. begin
  372.   SendQueue.Free;
  373.   CryptReleaseContext(CAPIProvider,0);
  374. end;
  375.  
  376. procedure TIBSecMainForm.ClearLog1Click(Sender: TObject);
  377. begin
  378.   Log.Clear;
  379. end;
  380.  
  381. procedure TIBSecMainForm.LogEnabled1Click(Sender: TObject);
  382. begin
  383.   LogEnabled1.Checked := Not LogEnabled1.Checked;
  384. end;
  385.  
  386. end.
  387.